home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / compiler / Exec_phr.sml < prev    next >
Encoding:
Text File  |  1997-08-18  |  3.9 KB  |  138 lines  |  [TEXT/R*ch]
  1. (* Exec_phr.sml *)
  2. open List BasicIO Nonstdio Miscsys Fnlib Mixture Globals Units Types Asynt;
  3. open Infixst Ovlres Infixres Elab Pr_zam Tr_env Front Back Compiler;
  4. open Symtable Rtvals Load_phr;
  5.  
  6. (* Executing a top-level declaration. *)
  7.  
  8. fun report_results iBas cBas static_VE static_TE =
  9.   let val firstLine = ref true in
  10.     app
  11.       (fn x =>
  12.          (msgIBlock 0;
  13.           if !firstLine then (firstLine := false; msgPrompt "")
  14.                         else msgContPrompt "";
  15.           reportFixityResult x;
  16.           msgEOL();
  17.           msgEBlock()))
  18.       (cleanEnv iBas);
  19.     app
  20.       (fn (id, tn) =>
  21.          (msgIBlock 0;
  22.           if !firstLine then (firstLine := false; msgPrompt "")
  23.                         else msgContPrompt "";
  24.           reportTypeResult tn;
  25.           msgEOL();
  26.           msgEBlock()))
  27.       (cleanEnv static_TE);
  28.     app
  29.       (fn (id,sch) =>
  30.          let val status = lookup_new_cBas cBas id
  31.              val {qualid, info} = status
  32.          in
  33.            msgIBlock 0;
  34.            msgCBlock 0;
  35.            (if !firstLine then (firstLine := false; msgPrompt)
  36.                          else msgContPrompt)
  37.              (case info of
  38.                  VARname  _ => "val "
  39.                | PRIMname _ => "val "
  40.                | CONname  _ => "con "
  41.                | EXNname  _ => "exn "
  42.                | REFname    => "con ");
  43.            msgString id;
  44.            msgString " ="; msgBreak(1, 4);
  45.            (case info of
  46.                VARname _  =>
  47.                  let val slot = get_slot_for_variable (lookupRenEnv qualid)
  48.                      val v = getGlobalVal slot
  49.                  in printVal sch v end
  50.              | PRIMname pi =>
  51.                  if #primArity pi  = 0 then
  52.                    msgString "-"
  53.                  else
  54.                    msgString "fn"
  55.              | CONname ci =>
  56.                  if #conArity(!ci) = 0 then
  57.                    printVQ qualid
  58.                  else
  59.                    msgString "fn"
  60.              | EXNname ei  =>
  61.                  if #exconArity(!ei) = 0 then
  62.                    printVQ qualid
  63.                  else
  64.                    msgString "fn"
  65.              | REFname =>
  66.                  msgString "fn");
  67.            msgBreak(1, 4); msgString ": "; printScheme sch;
  68.            msgEBlock();
  69.            msgEOL();
  70.            msgEBlock()
  71.          end)
  72.       (cleanEnv static_VE)
  73.   end
  74. ;
  75.  
  76. (* This is written in tail-recursive form to ensure *)
  77. (* that the intermediate results will be discarded. *)
  78.  
  79. fun updateCurrentState ((iBas, cBas, VE, TE), RE) =
  80. (
  81.   catch_interrupt false;
  82.   updateCurrentInfixBasis iBas;
  83.   updateCurrentConBasis cBas;
  84.   updateCurrentStaticTE TE;
  85.   updateCurrentStaticVE VE;
  86.   updateCurrentRenEnv RE;
  87.   catch_interrupt true;
  88.   report_results iBas cBas VE TE;
  89.   msgFlush()
  90. );
  91.  
  92. fun execLamPhrase state (RE, tlams) =
  93. (
  94.   app
  95.     (fn (is_pure, lam) =>
  96.       ( (*   msgIBlock 0; Pr_lam.printLam lam; msgEOL(); msgEBlock();  *)
  97.        ignore (loadZamPhrase
  98.          let val zam = compileLambda is_pure lam in
  99.              (* printZamPhrase zam; msgFlush();   *)
  100.            zam
  101.          end)
  102.       ))
  103.     tlams;
  104.     updateCurrentState (state, RE)
  105. );
  106.  
  107. fun execResolvedDecPhrase (iBas, cBas, dec) =
  108.   let val (VE, TE) = elabToplevelDec dec in
  109.     resolveOvlDec dec;
  110.     execLamPhrase (iBas, cBas, VE, TE) (translateToplevelDec dec)
  111.   end
  112. ;
  113.  
  114. fun execToplevelPhrase dec =
  115.   execResolvedDecPhrase (resolveToplevelDec dec)
  116. ;
  117.  
  118. (* Executing a top-level signature specification *)
  119.  
  120. (* This is written in tail-recursive form to ensure *)
  121. (* that the intermediate results will be discarded. *)
  122.  
  123. fun updateCurrentSigState (iBas, cBas, VE, TE) =
  124. (
  125.   updateCurrentInfixBasis iBas;
  126.   updateCurrentConBasis cBas;
  127.   updateCurrentStaticTE TE;
  128.   updateCurrentStaticVE VE;
  129.   report_comp_results iBas cBas VE TE;
  130.   msgFlush()
  131. );
  132.  
  133. fun execToplevelSpecPhrase spec =
  134.   let val (iBas, cBas) = resolveToplevelSpec spec
  135.       val (VE, TE) = elabToplevelSpec spec
  136.   in updateCurrentSigState (iBas, cBas, VE, TE) end
  137. ;
  138.